Shareware Grab Bag/Shareware Grab Bag.iso/007/ezwind.arc/EZWIND.PAS

Pascal/Delphi Source File | 1986-03-09 | 8.9 KB | 385 lines

{ EZWIND.PAS }

{ Collection of screen I/O routines  }


{ Written by Bill Bliss, 76474,154   }
{ Uploaded to CompuServe on 2-10-86  }

{  These routines contain some routines for directly writing to screen
   memory in Turbo Pascal.

   Although they have not been optimized for speed, they do utilize a
   model for screen memory that is extremely readable and provides for
   easy debugging.

   There is also a rudimentary level of window support; i.e. one window
   on the screen at one time.  The method used for saving the screen is
   not memory efficient, either; the routines essentially reserve a 4K
   buffer that is a copy of the screen.  This is partially because it is
   easy, but partially because I developed these routines for other
   purposes besides this!

   Also, realize that originally these routines took advantage of the
   procedures MoveToScreen and MoveFromScreen found in Borland's Turbo
   Editor Toolbox which avoid snow on the IBM C/G adapter.  For obvious
   reasons, these routines do not include that code.  I rewrote them
   into empty shells which now do a simple Turbo Move.

   Also, when I was working with the Editor routines, I found that there
   was a slight bug; you could not move data in and out of memory in one
   byte increments.  Hence, I had to kludge a little to get around this.
   I probably could've rewritten the Editor routines, but I didn't feel
   like it at the time!

   These routines WILL cause snow on the IBM C/G adapter and Hercules C/G
   adapter, but will NOT cause snow on the IBM Mono adapter, Zenith C/G
   adapter, or IBM EGA.  Other systems have not been tested.

   These routines should work with any IBM PC/Compatible, and although I
   haven't tested it, with Turbo 2.0 or above.  They definitely work with
   3.01A, though.

   These routines are rather sparsely documented, so if you have any questions
   please contact me!.

                                                     }


type
  RegPack = record
              AX,BX,CX,DX,BP,SI,DI,DS,ES,FLAGS : integer
            end;
  AnyStr = string[255];

const
  DefBGColor : byte = blue;

type
  VideoModes = (CGA,MONO,PCjr,EGA);
  ScrChar = record
              ScrChar : char;
              Attr : byte
            end;
  ScreenBuf = array[1..25,1..80] of ScrChar;
  ScreenBufPtr = ^ScreenBuf;

var
  VideoSeg,TempScreen : ScreenBufPtr;
  TempAttr,OldX,OldY : byte;


function VideoMode : VideoModes;

var
  Registers : RegPack;

begin
  Registers.AX := $0F00;
  Intr($10,Registers);
  case Lo(Registers.AX) of
     0..6 : VideoMode := CGA;
        7 : VideoMode := MONO;
      8,9 : VideoMode := PCjr;
   10..15 : VideoMode := EGA
  end
end;


procedure MoveToScreen(Var Source,Dest; Length: Integer);

begin
  Move(Source,Dest,Length)
end;


procedure MoveFromScreen(Var Source,Dest; Length: Integer);

begin
  Move(Source,Dest,Length)
end;


procedure CursorOff;

var
  Registers : RegPack;

begin
  Registers.AX := $0300;
  Registers.BX := 0;
  Intr($10,Registers);
  Registers.CX := Registers.CX or $2000;
  Registers.AX := $0100;
  Intr($10,Registers)
end;


procedure CursorOn;

var
  Registers : RegPack;

begin
  Registers.AX := $0300;
  Registers.BX := 0;
  Intr($10,Registers);
  Registers.CX := Registers.CX and $DFFF;
  Registers.AX := $0100;
  Intr($10,Registers)
end;


procedure GetVideoSegment;

begin
  if VideoMode = MONO then
    VideoSeg := Ptr($B000,0)
  else
    VideoSeg := Ptr($B800,0)
end;


function ComputeAttr(FC,BC : byte) : byte;

begin
  if FC >= Blink then
    ComputeAttr := ((BC shl 4) + (FC - Blink)) or $80
  else
    ComputeAttr := ((BC shl 4) + FC) and $7F
end;


procedure WriteAt(p : ScreenBufPtr;
                  x,y : byte;
                  ch : char;
                  Attr : byte);

var
  j : integer;

begin
  j := (Attr shl 8) + byte(ch);
  MoveToScreen(j,p^[x,y],2)
end;


procedure ClearBuf(p : ScreenBufPtr);

begin
  FillChar(p^,4000,0)
end;


procedure WriteStrAt(p : ScreenBufPtr;
                     x,y : byte;
                     S : AnyStr;
                     FG,BG,HFG,HBG : byte);

var
  i,j : byte;
  NormAttr,HiAttr : byte;

begin
  i := 0;
  j := 0;
  NormAttr := ComputeAttr(FG,BG);
  HiAttr := ComputeAttr(HFG,HBG);
  repeat
    i := i+1;
    if S[i] = '~' then
      repeat
        i := i+1;
        if S[i] <> '~' then
          begin
            WriteAt(p,x,y+j,S[i],HiAttr);
            j := j+1
          end
      until S[i] = '~'
    else
      begin
        WriteAt(p,x,y+j,S[i],NormAttr);
        j := j+1
      end
  until (i = Length(S)) or (y+j = 80)
end;


procedure CenterStrAt(p : ScreenBufPtr;
                      x : byte;
                      S : AnyStr;
                      FG,BG,HFG,HBG : byte);
var
  i,j : byte;

begin
  j := 0;
  for i := 1 to Length(S) do
    if S[i] = '~' then
      j := j+1;
  i := (80 - Length(S) + j) div 2;
  WriteStrAt(p,x,i,S,FG,BG,HFG,HBG)
end;


procedure HiLiteBar(p : ScreenBufPtr;
                    row,col,width,HFC,HBC : byte);

var
  i : byte;
  j : integer;
  Attr : byte;

begin
  Attr := ComputeAttr(HFC,HBC);
  for i := col to (col + width) do
    begin
      MoveFromScreen(p^[row,i],j,2);
      j := (Attr shl 8) + Lo(j);
      MoveToScreen(j,p^[row,i],2)
    end
end;


procedure DrawBox(p : ScreenBufPtr;
                  UpLeftX,
                  UpLeftY,
                  LowRightX,
                  LowRightY : byte;
                  FG,BorBG,IntBG : byte);

var
  i,j : integer;
  Attr : byte;

begin
  Attr := ComputeAttr(FG,BorBG);
  WriteAt(p,UpLeftX,UpLeftY,'I',Attr);
  for i := (UpLeftY + 1) to (LowRightY - 1) do
    WriteAt(p,UpLeftX,i,'M',Attr);
  WriteAt(p,UpLeftX,i+1,';',Attr);
  for i := (UpLeftX + 1) to (LowRightX - 1) do
      begin
        WriteAt(p,i,UpLeftY,':',Attr);
        WriteAt(p,i,LowRightY,':',Attr);
      end;
  WriteAt(p,LowRightX,UpLeftY,'H',Attr);
  for i := (UpLeftY + 1) to (LowRightY - 1) do
    WriteAt(p,LowRightX,i,'M',Attr);
  WriteAt(p,LowRightX,LowRightY,'<',Attr);

  for i := (UpLeftX + 1) to (LowRightX - 1) do
    for j := (UpLeftY + 1) to (LowRightY - 1) do
      WriteAt(p,i,j,' ',IntBg)

end;


procedure MakeWindow(p : ScreenBufPtr;
                     Ulx,Uly,Lrx,Lry,WindFG,WindBG : byte);

var
  i,j : byte;
  k : integer;

begin
  OldX := WhereX;
  OldY := WhereY;
  k := DefBGColor shl 12;
  for i := Ulx to Lrx do
    begin
      MoveFromScreen(VideoSeg^[i,Uly],p^[i,Uly],(Lry-Uly+1)*2);
      for j := Uly to Lry do
        MoveToScreen(k,VideoSeg^[i,j],2);
    end;
  DrawBox(VideoSeg,Ulx,Uly,Lrx,Lry,WindFG,WindBG,WindBG);
  Window(Uly+2,Ulx+1,Lry-2,Lrx-1);
  GotoXY(1,1)
end;


procedure RestoreWindow(p : ScreenBufPtr;
                        Ulx,Uly,Lrx,Lry : byte);

var
  i,j : byte;

begin
  for i := Ulx to Lrx do
    MoveFromScreen(p^[i,Uly],VideoSeg^[i,Uly],(Lry-Uly+1)*2);
  Window(1,1,80,25);
  GotoXY(OldX,OldY);
end;


{ short demo program follows: }

begin
  ClrScr;

  new(TempScreen);   { Allocate memory for screen buffer }
  GetVideoSegment;   { Set video segment }

  TempAttr := ComputeAttr(Yellow,Blue);

  write('Write a B at 10,10;  Press any key to continue...');
  WriteAt(VideoSeg,10,10,'B',TempAttr);

  repeat until keypressed;

  ClrScr;

  CursorOff;
  writeln('Turn the cursor off; press any key...');
  repeat until keypressed;
  write('Then back on again; press any key...');
  CursorOn;

  repeat until keypressed;

  ClrScr;

  writeln('Write a string at any place on the screen:');
  writeln('Surround any part of the string with the tilde (~) character');
  writeln('to have it appear in the highlighted color.');

  WriteStrAt(VideoSeg,10,10,
             'This is a ~test~ string.  Press ~any~ key to continue.',
             Blue,Yellow,Black,White);

  repeat until keypressed;

  ClrScr;
  writeln('Center a string at any line on the screen:');
  writeln('Again, surround any part of the string with the tilde (~) character');
  writeln('to have it appear in the highlighted color.');

  CenterStrAt(VideoSeg,20,
             'This is a ~test~ string.  Press ~any~ key to continue.',
             Blue,Yellow,Black,White);

  repeat until keypressed;

  ClrScr;
  writeln('You can highlight a bar on the screen, too: ');
  write('Press any key to continue...');

  WriteStrAt(VideoSeg,10,10,'Highlighted!!',Blue,Yellow,Black,White);
  HiLiteBar(VideoSeg,10,10,15,Black,White);

  repeat until keypressed;

  MakeWindow(TempScreen,2,5,10,60,White,Green);

  writeln('Now we are inside a window');
  write('Press any key to make window disappear...');

  repeat until keypressed;

  RestoreWindow(TempScreen,2,5,10,60);

  delay(1500);

  dispose(tempscreen)     { Deallocate memory }
end.